home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / packages / hyper-apropos.el < prev    next >
Encoding:
Text File  |  1995-07-24  |  30.7 KB  |  876 lines
  1. ;;; hyper-apropos.el --- Hypertext emacs lisp documentation interface.
  2.  
  3. ;; Copyright (C) 1994, 1995 Tinker Systems and INS Engineering Corp.
  4. ;; Copyright (C) 1995 Sun Microsystems.
  5.  
  6. ;; Maintainer: Jonathan Stigelman <Stig@hackvan.com>
  7. ;; Keywords: lisp, tools, help, docs, matching
  8.  
  9. ;; This file is part of XEmacs.
  10.  
  11. ;; XEmacs is free software; you can redistribute it and/or modify
  12. ;; it under the terms of the GNU General Public License as published by
  13. ;; the Free Software Foundation; either version 2 of the License, or
  14. ;; (at your option) any later version.
  15. ;; 
  16. ;; XEmacs is distributed in the hope that it will be useful,
  17. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19. ;; GNU General Public License for more details.
  20. ;; 
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with XEmacs; if not, write to the Free Software
  23. ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  24.  
  25. ;;; Synched up with: Not in FSF.
  26.  
  27. ;;; Commentary:
  28.  
  29. ;;  based upon emacs-apropos.el by Frank C. Guida <fcg@philabs.philips.com>
  30. ;;
  31. ;;  Rather than run apropos and print all the documentation at once,
  32. ;;  I find it easier to view a "table of contents" first, then
  33. ;;  get the details for symbols as you need them.
  34. ;;
  35. ;;  This version of apropos prints two lists of symbols matching the
  36. ;;  given regexp:  functions/macros and variables/constants.
  37. ;;
  38. ;;  The user can then do the following:
  39. ;;
  40. ;;      - add an additional regexp to narrow the search
  41. ;;      - display documentation for the current symbol
  42. ;;      - find the tag for the current symbol
  43. ;;      - show any keybindings if the current symbol is a command
  44. ;;    - invoke functions
  45. ;;    - set variables
  46. ;;
  47. ;;  An additional feature is the ability to search the current tags
  48. ;;  table, allowing you to interrogate functions not yet loaded (this
  49. ;;  isn't available with the standard package).
  50. ;;
  51. ;;  Mouse bindings and menus are provided for XEmacs.
  52. ;;
  53. ;; additions by Ben Wing <wing@netcom.com> July 1995:
  54. ;; added support for function aliases, made programmer's apropos be the
  55. ;; default, various other hacking.
  56.  
  57. ;;; Code:
  58.  
  59. (or (fboundp 'pprint)
  60.     (progn (autoload 'pp "pp")
  61.        (fset 'pprint 'pp)))
  62. ;;(require 'tags "etags")
  63.  
  64. ;;;###autoload
  65. (defvar hypropos-show-brief-docs t
  66.   "*If non-nil, `hyper-apropos' will display some documentation in the
  67. \"*Hyper Apropos*\" buffer.  Setting this to nil will speed up searches.")
  68.  
  69. (defvar hypropos-prettyprint-long-values t
  70.   "*If non-nil, then try to beautify the printing of very long values.")
  71.  
  72. ;; I changed this to true because I think it's more useful this way. --ben
  73.  
  74. (defvar hypropos-programming-apropos t
  75.   "*If non-nil, then `hyper-apropos' takes a bit longer and generates more
  76. output.  If nil, then only functions that are interactive and variables that
  77. are user variables are found by `hyper-apropos'.")
  78.  
  79. (defvar hypropos-prev-wconfig)
  80.  
  81. ;; #### - move this to subr.el
  82. (or (fboundp 'event-buffer)
  83.     (defun event-buffer (event)
  84.       "Returns the buffer associated with event, or nil."
  85.       (let ((win (event-window event)))
  86.     (and win (window-buffer win)))))
  87.  
  88. (defmacro eval-in-buffer (buffer &rest forms)
  89.   "Evaluate FORMS in BUFFER."
  90.   (` (let ((_unwind_buf_ (current-buffer)))
  91.        (unwind-protect
  92.        (progn (set-buffer (, buffer))
  93.           (,@ forms))
  94.      (set-buffer _unwind_buf_)))))
  95. (put 'eval-in-buffer 'lisp-indent-function 'defun)
  96.      
  97. ;; #### - move to faces.el
  98. (defmacro init-face (face &rest init-forms)
  99.   "Make a FACE if it doesn't already exist.  Then if it does not differ from
  100. the default face, execute INIT-FORMS to initialize the face.  While the
  101. init-forms are executing, the symbol `this' is bound to the face-object
  102. being initialized." 
  103.   (` (let ((this (make-face (, face))))    ; harmless if the face is already there
  104.      (or (face-differs-from-default-p this)
  105.      (, (cons 'progn init-forms))))))
  106. (put 'init-face 'lisp-indent-function 'defun)
  107.  
  108. (init-face 'hyperlink
  109.   (copy-face 'bold this)
  110.   ;;(set-face-underline-p this nil) -- dog slow and ugly
  111.   (condition-case nil
  112.       (set-face-foreground this "blue")
  113.     (error nil)))
  114. (init-face 'documentation
  115.   (let* ((ff-instance (face-font-instance 'default))
  116.     (ff (and ff-instance (font-instance-name ff-instance))))
  117.     (cond ((and ff (string-match "courier" ff))
  118.        ;; too wide unless you shrink it
  119.        ;; (copy-face 'italic this) fugly.
  120.        ;; (make-face-smaller this) fugly.
  121.        ))
  122.     (condition-case nil
  123.     (set-face-foreground this "firebrick")
  124.       (error (copy-face 'italic this)))))
  125.  
  126. ;; mucking with the sizes of fonts (perhaps with the exception of courier or
  127. ;; misc) is a generally losing thing to do.  Changing the size of 'clean'
  128. ;; really loses, for instance...
  129.  
  130. (init-face 'major-heading
  131.   (copy-face 'bold this)
  132.   (make-face-larger this)
  133.   (make-face-larger this))
  134. (init-face 'section-heading
  135.   (copy-face 'bold this)
  136.   (make-face-larger this))
  137. (init-face 'heading
  138.   (copy-face 'bold this))
  139. (init-face 'standout
  140.   (copy-face 'italic this))
  141.  
  142. (init-face 'warning
  143.   (copy-face 'bold this)
  144.   (and (eq (device-type) 'x)
  145.        (eq (device-class) 'color)
  146.        (set-face-foreground this "red")))
  147.  
  148. (defvar hypropos-help-map (let ((map (make-sparse-keymap)))
  149.                 (suppress-keymap map)
  150.                 (set-keymap-name map 'hypropos-help-map)
  151.                 ;; movement
  152.                 (define-key map " "     'scroll-up)
  153.                 (define-key map "b"     'scroll-down)
  154.                 (define-key map "/"     'isearch-forward)
  155.                 (define-key map "?"     'isearch-backward)
  156.                 ;; follow links
  157.                 (define-key map "\r"    'hypropos-get-doc)
  158.                 (define-key map "s"     'hypropos-set-variable)
  159.                 (define-key map "t"     'hypropos-find-tag)
  160.                 (define-key map "l"     'hypropos-last-help)
  161.                 (define-key map [button2] 'hypropos-mouse-get-doc)
  162.                 (define-key map [button3] 'hypropos-popup-menu)
  163.                 ;; for the totally hardcore...
  164.                 (define-key map "D"     'hypropos-disassemble)
  165.                 ;; administrativa
  166.                 (define-key map "a"     'hyper-apropos)
  167.                 (define-key map "n"     'hyper-apropos)
  168.                 (define-key map "q"     'hypropos-quit)
  169.                 map
  170.                 )
  171.   "Keybindings for both the *Hyper Help* buffer and the *Hyper Apropos* buffer")
  172.  
  173. (defvar hypropos-map (let ((map (make-sparse-keymap)))
  174.                (set-keymap-name map 'hypropos-map)
  175.                (set-keymap-parents map (list hypropos-help-map))
  176.                ;; slightly differrent scrolling...
  177.                (define-key map " "     'hypropos-scroll-up)
  178.                (define-key map "b"     'hypropos-scroll-down)
  179.                ;; act on the current line...
  180.                (define-key map "w"     'hypropos-where-is)
  181.                (define-key map "i"     'hypropos-invoke-fn)
  182.                (define-key map "s"     'hypropos-set-variable)
  183.                ;; more administrativa...
  184.                (define-key map "P"     'hypropos-toggle-programming-flag)
  185.                (define-key map "k"     'hypropos-add-keyword)
  186.                (define-key map "e"     'hypropos-eliminate-keyword)
  187.                map
  188.                )
  189.   "Keybindings for the *Hyper Apropos* buffer.
  190. This map inherits from `hypropos-help-map.'")
  191.  
  192. (defvar hyper-apropos-mode-hook nil
  193.   "*User function run after hyper-apropos mode initialization.  Usage:
  194. \(setq hyper-apropos-mode-hook '(lambda () ... your init forms ...)).")
  195.  
  196. ;; ---------------------------------------------------------------------- ;;
  197.  
  198. (defconst hypropos-junk-regexp "^Apropos\\|^Functions\\|^Variables\\|^$")
  199.  
  200. (defvar hypropos-currently-showing nil)    ; symbol documented in help buffer now
  201. (defvar hypropos-help-history nil)    ; chain of symbols followed as links in
  202.                     ; help buffer
  203. (defvar hypropos-last-regexp nil)    ; regex used for last apropos
  204. (defconst hypropos-apropos-buf "*Hyper Apropos*")
  205. (defconst hypropos-help-buf "*Hyper Help*")
  206.  
  207. ;;;###autoload
  208. (defun hyper-apropos (regexp toggle-apropos)
  209.   "Display lists of functions and variables matching REGEXP
  210. in buffer \"*Hyper Apropos*\".  If optional prefix arg is given, then the value
  211. of `hypropos-programming-apropos' is toggled for this search.
  212. See also `hyper-apropos-mode'."
  213.   (interactive "sList symbols matching regexp: \nP")
  214.   (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
  215.       (setq hypropos-prev-wconfig (current-window-configuration)))
  216.   (if (string= "" regexp)
  217.       (if (get-buffer hypropos-apropos-buf)
  218.       (if toggle-apropos
  219.           (hypropos-toggle-programming-flag)
  220.         (message "Using last search results"))
  221.     (error "Be more specific..."))
  222.     (let (flist vlist)
  223.       (set-buffer (get-buffer-create hypropos-apropos-buf))
  224.       (setq buffer-read-only nil)
  225.       (erase-buffer)
  226.       (if toggle-apropos
  227.       (set (make-local-variable 'hypropos-programming-apropos)
  228.            (not (default-value 'hypropos-programming-apropos))))
  229.       (if (not hypropos-programming-apropos)
  230.       (setq flist (apropos-internal regexp 'commandp)
  231.         vlist (apropos-internal regexp 'user-variable-p))
  232.     ;; #### - add obsolete functions/variables here...
  233.     ;; #### - 'variables' may be unbound !!!
  234.     (setq flist (apropos-internal regexp 'fboundp)
  235.           vlist (apropos-internal regexp 'boundp)))
  236.       (insert-face (format "Apropos search for: %S\n\n" regexp) 'major-heading)
  237.       (insert-face "* = command (M-x) or user-variable.\n" 'documentation)
  238.       (insert-face "a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.\n\n" 'documentation)
  239.       (insert-face "Functions and Macros:\n\n" 'major-heading)
  240.       (hypropos-grok-functions flist)
  241.       (insert-face "\n\nVariables and Constants:\n\n" 'major-heading)
  242.       (hypropos-grok-variables vlist)
  243.       (goto-char (point-min))
  244.       ))
  245.   (switch-to-buffer hypropos-apropos-buf)
  246.   (hyper-apropos-mode regexp))
  247.  
  248. (defun hypropos-toggle-programming-flag ()
  249.   (interactive)
  250.   (eval-in-buffer hypropos-apropos-buf
  251.     (set (make-local-variable 'hypropos-programming-apropos)
  252.      (not hypropos-programming-apropos)))
  253.   (message "Re-running apropos...")
  254.   (hyper-apropos hypropos-last-regexp nil))
  255.  
  256. (defun hypropos-grok-functions (fns)
  257.   (let (fn bind doc type)
  258.     (while (setq fn (car fns))
  259.       (setq bind (symbol-function fn)
  260.         type (cond ((subrp bind) ?i)
  261.                ((compiled-function-p bind) ?b)
  262.                ((consp bind) (or (cdr
  263.                       (assq (car bind) '((autoload . ?a)
  264.                                  (lambda . ?l)
  265.                                  (macro . ?m))))
  266.                      ??))
  267.                (t ? )))
  268.       (insert type (if (commandp fn) "* " "  "))
  269.       (insert-face (format "%-30S" fn) 'hyperlink)
  270.       (and hypropos-show-brief-docs
  271.        (setq doc (documentation fn))
  272.        (insert-face (concat " - "
  273.                 (substring doc 0 (string-match "\n" doc)))
  274.             'documentation))
  275.       (insert ?\n)
  276.       (setq fns (cdr fns))
  277.       )))
  278.  
  279. (defun hypropos-grok-variables (vars)
  280.   (let (var doc userp)
  281.     (while (setq var (car vars))
  282.       (setq userp (user-variable-p var)
  283.         vars (cdr vars))
  284.       (insert (if userp " * " "   "))
  285.       (insert-face (format "%-30S" var) 'hyperlink)
  286.       (and hypropos-show-brief-docs
  287.        (setq doc (documentation-property var 'variable-documentation))
  288.        (insert-face (concat " - " (substring doc (if userp 1 0)
  289.                          (string-match "\n" doc)))
  290.             'documentation))
  291.       (insert ?\n)
  292.       )))
  293.  
  294. ;; ---------------------------------------------------------------------- ;;
  295.  
  296. (defun hyper-apropos-mode (regexp)
  297.   "Improved apropos mode for displaying Emacs documentation.  Function and
  298. variable names are displayed in the buffer \"*Hyper Apropos*\".  
  299.  
  300. Functions are preceded by a single character to indicates their types:
  301.     a = autoloaded, b = byte-compiled, i = internal, l = lambda, m = macro.
  302. Interactive functions are also preceded by an asterisk.
  303. Variables are preceded by an asterisk if they are user variables.
  304.  
  305. General Commands:
  306.  
  307.       SPC    - scroll documentation or apropos window forward
  308.         b    - scroll documentation or apropos window backward
  309.       k     - eliminate all hits that don't contain keyword
  310.       n    - new search
  311.         /    - isearch-forward
  312.         q    - quit and restore previous window configuration
  313.   
  314.   Operations for Symbol on Current Line:
  315.   
  316.           RET     - toggle display of symbol's documentation
  317.           (also on button2 in xemacs)
  318.         w     - show the keybinding if symbol is a command
  319.         i    - invoke function on current line
  320.         s    - set value of variable on current line
  321.       t    - display the C or lisp source (find-tag)"
  322.   (delete-other-windows)
  323.   (setq mode-name "Hyper-Apropos"
  324.     major-mode 'hyper-apropos-mode
  325.     buffer-read-only t
  326.     truncate-lines t
  327.     hypropos-last-regexp regexp
  328.     modeline-buffer-identification (concat "Hyper Apropos: "
  329.                            "\"" regexp "\""))
  330.   (setq mode-motion-hook 'mode-motion-highlight-line)
  331.   (use-local-map hypropos-map)
  332.   (run-hooks 'hyper-apropos-mode-hook))
  333.  
  334. ;; ---------------------------------------------------------------------- ;;
  335.  
  336. ;;;###autoload
  337. (defun hyper-describe-variable (symbol)
  338.   "Hypertext drop-in replacement for `describe-variable'.
  339. See also `hyper-apropos' and `hyper-describe-function'."
  340.   ;; #### - perhaps a prefix arg should suppress the prompt...
  341.   (interactive 
  342.    (let* ((v (variable-at-point))
  343.           (val (let ((enable-recursive-minibuffers t))
  344.                  (completing-read
  345.           (if v
  346.               (format "Describe variable (default %s): " v)
  347.             "Describe variable: ")
  348.           obarray 'boundp t))))
  349.      (list (if (string= val "") v (intern-soft val)))))
  350.   (if (null symbol)
  351.       (message "Sorry, nothing to describe.")
  352.     (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
  353.     (setq hypropos-prev-wconfig (current-window-configuration)))
  354.     (hypropos-get-doc symbol t)))
  355.  
  356. ;;;###autoload
  357. (defun hyper-describe-function (symbol)
  358.   "Hypertext replacement for `describe-function'.  Unlike `describe-function'
  359. in that the symbol under the cursor is the default if it is a function.
  360. See also `hyper-apropos' and `hyper-describe-variable'."
  361.   ;; #### - perhaps a prefix arg should suppress the prompt...
  362.   (interactive
  363.    (let (fn val)
  364.      (setq fn (hypropos-this-symbol))    ; symbol under point
  365.      (or (fboundp fn)
  366.      (setq fn (function-called-at-point)))
  367.      (setq val (let ((enable-recursive-minibuffers t))
  368.          (completing-read
  369.           (if fn 
  370.               (format "Describe function (default %s): " fn)
  371.             "Describe function: ")
  372.           obarray 'fboundp t)))
  373.      (list (if (equal val "") fn (intern-soft val)))))
  374.   (if (null symbol)
  375.       (message "Sorry, nothing to describe.")
  376.     (or (memq major-mode '(hyper-apropos-mode hyper-help-mode))
  377.     (setq hypropos-prev-wconfig (current-window-configuration)))
  378.     (hypropos-get-doc symbol t)))
  379.  
  380. (defun hypropos-last-help (arg)
  381.   "Go back to the last symbol documented in the *Hyper Help* buffer."
  382.   (interactive "P")
  383.   (let ((win (get-buffer-window hypropos-help-buf))
  384.     (n (prefix-numeric-value arg)))
  385.     (cond ((and (not win) (not arg))
  386.        ;; don't alter the help-history, just redisplay
  387.        )
  388.       ((<= (length hypropos-help-history) n)
  389.        ;; go back as far as we can...
  390.        (setcdr (nreverse hypropos-help-history) nil))
  391.       (t
  392.        (setq hypropos-help-history (nthcdr n hypropos-help-history))))
  393.     (hypropos-get-doc (car hypropos-help-history) t)))
  394.  
  395. (defun hypropos-get-doc (&optional symbol force type)
  396.   ;; #### - update this docstring
  397.   "Toggle display of documentation for the symbol on the current line."
  398.   ;; SYMBOL is the symbol to document.  FORCE, if non-nil, means to
  399.   ;; regenerate the documentation even if it already seems to be there.  And
  400.   ;; TYPE, if present, forces the generation of only variable documentation
  401.   ;; or only function documentation.  Normally, if both are present, then
  402.   ;; both will be generated.
  403.   ;;
  404.   ;; TYPES TO IMPLEMENT: obsolete face
  405.   ;;
  406.   (interactive)
  407.   (or symbol
  408.       (setq symbol (hypropos-this-symbol)))
  409.   (or type
  410.       (setq type '(function variable face)))
  411.   (if (and (eq hypropos-currently-showing symbol)
  412.        (get-buffer hypropos-help-buf)
  413.        (get-buffer-window hypropos-help-buf)
  414.        (not force))
  415.       ;; we're already displaying this help, so toggle its display.
  416.       (delete-windows-on hypropos-help-buf)
  417.     ;; OK, we've got to refresh and display it...
  418.     (or (eq symbol (car hypropos-help-history))
  419.     (setq hypropos-help-history
  420.           (if (eq major-mode 'hyper-help-mode)
  421.           ;; if we're following a link in the help buffer, then
  422.           ;; record that in the help history.
  423.           (cons symbol hypropos-help-history)
  424.         ;; otherwise clear the history because it's a new search.
  425.         (list symbol))))
  426.     (save-excursion
  427.       (set-buffer (get-buffer-create hypropos-help-buf))
  428.       (setq buffer-read-only nil)
  429.       (erase-buffer)
  430.       (let ((standard-output (current-buffer))
  431.         ok beg desc
  432.         ftype macrop fndef
  433.         keys val doc
  434.         obsolete aliases alias-desc)
  435.     (insert-face (format "`%s'\n\n" symbol) 'major-heading)
  436.     (and (memq 'function type)
  437.          (fboundp symbol)
  438.          (progn 
  439.            (setq ok t
  440.              fndef (symbol-function symbol))
  441.            (while (symbolp fndef)
  442.          (setq aliases (cons fndef aliases))
  443.          (setq fndef (symbol-function fndef)))
  444.            (if (eq 'macro (car-safe fndef))
  445.            (setq macrop t
  446.              fndef (cdr fndef)))
  447.            (setq aliases (nreverse aliases))
  448.            ;; #### - the gods of internationalization shall strike me down!
  449.            (while aliases
  450.          (if alias-desc
  451.              (setq alias-desc (concat alias-desc ",\nwhich is ")))
  452.          (setq alias-desc (concat alias-desc
  453.                       (format "an alias for `%s'"
  454.                           (car aliases))))
  455.          (setq aliases (cdr aliases)))
  456.            (setq ftype (cond ((subrp fndef)                   'subr)
  457.                  ((compiled-function-p fndef)     'bytecode)
  458.                  ((eq (car-safe fndef) 'autoload) 'autoload)
  459.                  ((eq (car-safe fndef) 'lambda)      'lambda))
  460.              desc (concat (if (commandp symbol) "interactive ")
  461.                   (cdr (assq ftype
  462.                          '((subr     . "built-in ")
  463.                            (bytecode . "compiled Lisp ")
  464.                            (autoload . "autoloaded Lisp ")
  465.                            (lambda   . "Lisp "))))
  466.                   (if macrop "macro" "function")
  467.                   ))
  468.            (if alias-desc
  469.            (setq desc (concat alias-desc
  470.                       (if (memq (aref desc 0)
  471.                         '(?a ?e ?i ?o ?u))
  472.                       ", an " ", a ")
  473.                       desc)))
  474.            (aset desc 0 (upcase (aref desc 0))) ; capitalize
  475.            (insert-face desc 'section-heading)
  476.            (and (eq ftype 'autoload)
  477.             (insert (format ", (autoloaded from \"%s\")"
  478.                     (nth 1 fndef))))
  479.            ;; #### - should also show local binding in some other
  480.            ;; buffer so that this function can be used in place of
  481.            ;; describe-function and describe-variable.
  482.            (if (setq keys (where-is-internal symbol (current-global-map)
  483.                          nil nil nil))
  484.            (insert (format ", (globally bound to %s)"
  485.                    (mapconcat
  486.                     #'(lambda (x)
  487.                     (format "\"%s\""
  488.                         (key-description x)))
  489.                     (sort keys #'(lambda (x y)
  490.                            (< (length x) (length y))))
  491.                     ", "))))
  492.            (insert ":\n\n")
  493.            (setq beg (point)
  494.              doc (or (documentation symbol) "function not documented"))
  495.            (insert-face "arguments: " 'heading)
  496.            (cond ((eq ftype 'lambda)
  497.               (princ (or (nth 1 fndef) "()")))
  498.              ((eq ftype 'bytecode)
  499.               (princ (or (aref fndef 0) "()")))
  500.              ((and (eq ftype 'subr)
  501.                (string-match
  502.                 "[\n\t ]*\narguments: ?\\((.*)\\)\n?\\'"
  503.                 doc))
  504.               (insert (substring doc
  505.                      (match-beginning 1)
  506.                      (match-end 1)))
  507.               (setq doc (substring doc 0 (match-beginning 0))))
  508.              (t (princ "[not available]")))
  509.            (insert "\n\n")
  510.            (let ((new
  511.               ;; cookbook from bytecomp.el
  512.               (get symbol 'byte-obsolete-info)))
  513.          (and new
  514.               (insert-face
  515.                (format "%s is an obsolete function; %s\n\n" symbol
  516.                    (if (stringp (car new))
  517.                    (car new)
  518.                  (format "use %s instead." (car new))))
  519.                'warning)))
  520.            (insert-face doc 'documentation)
  521.            (indent-rigidly beg (point) 1)
  522.            (insert"\n\n")
  523.            ))
  524.     (and (memq 'variable type)
  525.          (boundp symbol)
  526.          (progn 
  527.            (setq ok t)
  528.            (insert-face (if (user-variable-p symbol)
  529.                 "User variable"
  530.                   "Variable")
  531.                 'section-heading)
  532.            (and (local-variable-p symbol nil t)
  533.             (insert ", local when set"))
  534.            (insert ":\n\n")
  535.            (setq beg (point)
  536.              val (prin1-to-string (symbol-value symbol))
  537.              doc (or (documentation-property
  538.                   symbol 'variable-documentation)
  539.                  "variable not documented"))
  540.            
  541.            (let ((ob (get symbol 'byte-obsolete-variable)))
  542.          (setq obsolete
  543.                (and ob (format "%s is an obsolete variable; %s\n\n"
  544.                        symbol
  545.                        (if (stringp ob)
  546.                        ob
  547.                      (format "use %s instead." ob))))))
  548.            ;; generally, the value of the variable is short and the
  549.            ;; documentation of the variable long, so it's desirable
  550.            ;; to see all of the value and the start of the
  551.            ;; documentation.  Some variables, though, have huge and
  552.            ;; nearly meaningless values that force you to page
  553.            ;; forward just to find the doc string.  That is
  554.            ;; undesirable.
  555.            (if (< (length val) 69)    ; 80 cols.  docstrings assume this.
  556.            (progn (insert-face "value: " 'heading)
  557.               (insert (format "%s\n\n" val))
  558.               (and obsolete (insert-face obsolete 'warning))
  559.               (insert-face doc 'documentation))
  560.          (insert "(see below for value)\n\n")
  561.          (and obsolete (insert-face obsolete 'warning))
  562.          (insert-face doc 'documentation)
  563.          (insert "\n\n")
  564.          (insert-face "value: " 'heading)
  565.          (if hypropos-prettyprint-long-values
  566.              (let ((pp-print-readably nil))
  567.                (pprint (symbol-value symbol)))
  568.            (insert val)))
  569.            (indent-rigidly beg (point) 2)
  570.            ))
  571.     (and (memq 'face type)
  572.          (find-face symbol)
  573.          (progn
  574.            (setq ok t)
  575.            ;; #### - add some code here
  576.            (insert "Face documentation is \"To be implemented.\"\n\n")
  577.            )
  578.          )
  579.     (or ok (insert-face "symbol is not currently bound" 'heading)))
  580.       (goto-char (point-min)) 
  581.       ;; pop up window and shrink it if it's wasting space
  582.       (shrink-window-if-larger-than-buffer
  583.        (display-buffer (current-buffer))) 
  584.       (hyper-help-mode))    )
  585.   (setq hypropos-currently-showing symbol))
  586.  
  587. ; -----------------------------------------------------------------------------
  588.  
  589. (defun hyper-help-mode ()
  590.   "Major mode for hypertext XEmacs help.  In this mode, you can quickly
  591. follow links between back and forth between the documentation strings for
  592. different variables and functions.  Common commands:
  593.  
  594. \\{hypropos-help-map}"
  595.   (setq mode-motion-hook 'hypropos-highlight-lisp-symbol
  596.     buffer-read-only t
  597.     major-mode         'hyper-help-mode
  598.     mode-name         "Hyper-Help")
  599.   (set-syntax-table emacs-lisp-mode-syntax-table)
  600.   (use-local-map hypropos-help-map))
  601.  
  602. (defun hypropos-highlight-lisp-symbol (event)
  603.   ;; mostly copied from mode-motion-highlight-internal
  604.   (let* ((window (event-window event))
  605.      (buffer (and window (window-buffer window)))
  606.      (point (and buffer (event-point event)))
  607.      st en sym highlight-p)
  608.     (if buffer
  609.     (progn
  610.       (set-buffer buffer)
  611.       (if point
  612.           (save-excursion
  613.         (goto-char point)
  614.         (setq st (save-excursion
  615.                (skip-syntax-backward "w_")
  616.                (skip-chars-forward "`")
  617.                (point))
  618.               en (save-excursion
  619.                (goto-char st)
  620.                (skip-syntax-forward "w_")
  621.                (skip-chars-backward ".")
  622.                (point))
  623.               sym (and (not (eq st en))
  624.                    (intern-soft (buffer-substring st en)))
  625.               highlight-p (and sym
  626.                        (or (boundp sym)
  627.                        (fboundp sym))))
  628.         (if highlight-p
  629.             (if mode-motion-extent
  630.               (set-extent-endpoints mode-motion-extent st en)
  631.             (setq mode-motion-extent (make-extent st en))
  632.             (set-extent-property mode-motion-extent 'highlight t))
  633.           (and mode-motion-extent
  634.              (progn (delete-extent mode-motion-extent)
  635.                 (setq mode-motion-extent nil)))
  636.           ))
  637.         ;; not over text; zero the extent.
  638.         (if (and mode-motion-extent (extent-buffer mode-motion-extent)
  639.              (not (eq (extent-start-position mode-motion-extent)
  640.                   (extent-end-position mode-motion-extent))))
  641.         (set-extent-endpoints mode-motion-extent 1 1)))))))
  642.  
  643.  
  644. ;; ---------------------------------------------------------------------- ;;
  645.  
  646. (defun hypropos-scroll-up ()
  647.   "Scroll up the \"*Hyper Help*\" buffer if it's visible, or scroll this window up."
  648.   (interactive)
  649.   (let ((win (get-buffer-window hypropos-help-buf))
  650.     (owin (selected-window)))
  651.     (if win
  652.     (progn
  653.       (select-window win)
  654.       (condition-case nil
  655.            (scroll-up nil)
  656.           (error (goto-char (point-max))))
  657.       (select-window owin))
  658.       (scroll-up nil))))
  659.  
  660. (defun hypropos-scroll-down ()
  661.   "Scroll down the \"*Hyper Help*\" buffer if it's visible, or scroll this window down."
  662.   (interactive)
  663.   (let ((win (get-buffer-window hypropos-help-buf))
  664.     (owin (selected-window)))
  665.     (if win
  666.     (progn
  667.       (select-window win)
  668.       (condition-case nil
  669.            (scroll-down nil)
  670.           (error (goto-char (point-max))))
  671.       (select-window owin))
  672.       (scroll-down nil))))
  673.  
  674. ;; ---------------------------------------------------------------------- ;;
  675.  
  676. (defun hypropos-mouse-get-doc (event)
  677.   "Get the documentation for the symbol the mouse is on."
  678.   (interactive "e")
  679.   (mouse-set-point event)
  680.   (save-excursion
  681.     (let ((symbol (hypropos-this-symbol)))
  682.       (if symbol
  683.       (hypropos-get-doc symbol)
  684.     (error "Click on a symbol")))))
  685.  
  686. ;; ---------------------------------------------------------------------- ;;
  687.  
  688. (defun hypropos-add-keyword (pattern)
  689.   "Use additional keyword to narrow regexp match.
  690. Deletes lines which don't match PATTERN."
  691.   (interactive "sAdditional Keyword: ")
  692.   (save-excursion
  693.     (goto-char (point-min))
  694.     (let (buffer-read-only)
  695.       (keep-lines (concat pattern "\\|" hypropos-junk-regexp))
  696.       )))
  697.  
  698. (defun hypropos-eliminate-keyword (pattern)
  699.   "Use additional keyword to eliminate uninteresting matches.
  700. Deletes lines which match PATTERN."
  701.   (interactive "sKeyword to eliminate: ")
  702.   (save-excursion
  703.     (goto-char (point-min))
  704.     (let (buffer-read-only)
  705.       (flush-lines pattern))
  706.       ))
  707.  
  708. ;; ---------------------------------------------------------------------- ;;
  709.  
  710. (defun hypropos-this-symbol ()
  711.   (save-excursion
  712.     (cond ((eq major-mode 'hyper-apropos-mode)
  713.        (beginning-of-line)
  714.        (if (looking-at hypropos-junk-regexp)
  715.            nil
  716.          (forward-char 3)
  717.          (read (point-marker))))
  718.       (t
  719.        (let* ((st (progn
  720.             (skip-syntax-backward "w_")
  721.             ;; !@(*$^%%# stupid backquote implementation!!!
  722.             (skip-chars-forward "`")
  723.             (point)))
  724.           (en (progn
  725.             (skip-syntax-forward "w_")
  726.             (skip-chars-backward ".")
  727.             (point))))
  728.          (and (not (eq st en))
  729.           (intern-soft (buffer-substring st en))))))))
  730.  
  731. (defun hypropos-where-is (symbol)
  732.   "Find keybinding for symbol on current line."
  733.   (interactive (list (hypropos-this-symbol)))
  734.   (where-is symbol))
  735.  
  736. (defun hypropos-invoke-fn (fn)
  737.   "Interactively invoke the function on the current line."
  738.   (interactive (list (hypropos-this-symbol)))
  739.   (cond ((not (fboundp fn))
  740.      (error "%S is not a function" fn))
  741.     (t (call-interactively fn))))
  742.  
  743. ;;;###autoload
  744. (defun hypropos-set-variable (var val)
  745.   "Interactively set the variable on the current line."
  746.   (interactive
  747.    (let ((var (save-excursion
  748.         (and (eq major-mode 'hypropos-help-mode)
  749.              (goto-char (point-min)))
  750.         (hypropos-this-symbol))))
  751.      (or (boundp var)
  752.      (setq var (completing-read "Set variable: "
  753.                     obarray 'boundp t)))
  754.      (hypropos-get-doc var t)
  755.      (list var
  756.        (let ((prop (get var 'variable-interactive))
  757.          (print-readably t)
  758.          (val (symbol-value var)))
  759.          (if prop
  760.          (call-interactively (list 'lambda '(arg)
  761.                        (list 'interactive prop)
  762.                        'arg))
  763.            (eval-minibuffer
  764.         (format "Set `%s' to value (evaluated): " var)
  765.         (format (if (or (consp val)
  766.                 (and (symbolp val)
  767.                      (not (memq val '(t nil)))))
  768.                 "'%s" "%s")
  769.             (prin1-to-string val))))))
  770.      ))
  771.   (set var val)
  772.   (hypropos-get-doc var t))
  773.  
  774. ;; ---------------------------------------------------------------------- ;;
  775.  
  776. (defun hypropos-find-tag (&optional tag-name)
  777.   "Find the tag for the symbol on the current line in other window.  In
  778. order for this to work properly, the variable `tag-table-alist' or
  779. `tags-file-name' must be set so that a TAGS file with tags for the emacs
  780. source is found for the \"*Hyper Apropos*\" buffer."
  781.   (interactive)
  782.   ;; there ought to be a default tags file for this...
  783.   (or tag-name (setq tag-name (symbol-name (hypropos-this-symbol))))
  784.   (find-tag-other-window (list tag-name)))
  785.  
  786. ;; ---------------------------------------------------------------------- ;;
  787.  
  788. (defun hypropos-disassemble (sym)
  789.   "Disassemble FUN if it is byte-coded.  If it's a lambda, prettyprint it."
  790.   (interactive (list (hypropos-this-symbol)))
  791.   (let ((fun sym) (trail nil) macrop)
  792.     (while (and (symbolp fun) (not (memq fun trail)))
  793.       (setq trail (cons fun trail)
  794.         fun (symbol-function fun)))
  795.     (and (symbolp fun)
  796.      (error "Loop detected in function binding of `%s'" fun))
  797.     (setq macrop (and  (consp fun)
  798.                (eq 'macro (car fun))))
  799.     (cond ((compiled-function-p (if macrop (cdr fun) fun))
  800.        (disassemble fun)
  801.        (set-buffer "*Disassemble*")
  802.        (goto-char (point-min))
  803.        (forward-sexp 2)
  804.        (insert (format " for function `%S'" sym))
  805.        )
  806.       ((consp fun)
  807.        (with-output-to-temp-buffer "*Disassemble*"
  808.          (pprint (if macrop
  809.              (cons 'defmacro (cons sym (cdr (cdr fun))))
  810.                (cons 'defun (cons sym (cdr fun))))))
  811.        (set-buffer "*Disassemble*")
  812.        (emacs-lisp-mode))
  813.       ((or (vectorp fun) (stringp fun))
  814.        ;; #### - do something fancy here
  815.        (with-output-to-temp-buffer "*Disassemble*"
  816.          (princ (format "%s is a keyboard macro:\n\n\t" sym))
  817.          (prin1 fun)))
  818.       (t
  819.        (error "Sorry, cannot disassemble `%s'" sym)))))
  820.  
  821. ;; ---------------------------------------------------------------------- ;;
  822.  
  823. (defun hypropos-quit ()
  824.   (interactive)
  825.   "Quit Hyper Apropos and restore original window config."
  826.   (let ((buf (get-buffer hypropos-apropos-buf)))
  827.     (and buf (bury-buffer buf)))
  828.   (set-window-configuration hypropos-prev-wconfig))
  829.  
  830. ;; ---------------------------------------------------------------------- ;;
  831.  
  832. ;;;###autoload
  833. (defun hypropos-popup-menu (event)
  834.   (interactive "e")
  835.   (mouse-set-point event)
  836.   (let* ((sym (hypropos-this-symbol))
  837.      (notjunk (not (null sym)))
  838.      (command-p (commandp sym))
  839.      (variable-p (and sym (boundp sym)))
  840.      (function-p (fboundp sym))
  841.      (apropos-p (eq 'hyper-apropos-mode
  842.             (save-excursion (set-buffer (event-buffer event))
  843.                     major-mode)))
  844.      (name (if sym (symbol-name sym) ""))
  845.      (hypropos-menu
  846.       (delete
  847.        nil
  848.        (list (concat "Hyper-Help: " name)
  849.         (vector "Display documentation" 'hypropos-get-doc   notjunk)
  850.         (vector "Set variable"    'hypropos-set-variable    variable-p)
  851.         (vector "Show keys for"     'hypropos-where-is      command-p)
  852.         (vector "Invoke command"    'hypropos-invoke-fn    command-p)
  853.         (vector "Find tag"        'hypropos-find-tag    notjunk)
  854.         (and apropos-p
  855.          ["Add keyword..." hypropos-add-keyword    t])
  856.         (and apropos-p
  857.          ["Eliminate keyword..." hypropos-eliminate-keyword  t])
  858.         (if apropos-p
  859.         ["Programmers' Apropos" hypropos-toggle-programming-flag
  860.          :style toggle :selected hypropos-programming-apropos]
  861.           ["Programmers' Help" hypropos-toggle-programming-flag
  862.            :style toggle :selected hypropos-programming-apropos])
  863.         (and hypropos-programming-apropos
  864.          (vector "Disassemble function"
  865.              'hypropos-disassemble
  866.              function-p))
  867.         ["Help"                     describe-mode           t]
  868.         ["Quit"            hypropos-quit        t]
  869.         ))))
  870.     (popup-menu hypropos-menu)))
  871.  
  872. (provide 'hyper-apropos)
  873.  
  874. ;; end of hyper-apropos.el
  875.  
  876.